DEFINT A-Z

'====================================================================

'  van een datum het julian dagnummer uitrekenen
'  routine gehaald uit boek QuickBASIC 4.5 Programmeertoolkit
'  Acaddemic Service, schriver Tom Rugg en Phil Feldman
'  uit 1990.  Routine iets aangepast
'  Jr$ alleen de laatste 2 cijfers van het jaar
'  geldig van 1950 - 2050

DECLARE FUNCTION DagNummer& (Jr$, Mnd$, Dg$, Test)

'  van een bepaald julian dagnummer de datum bepalen
'  routine gehaald uit boek QuickBASIC 4.5 Programmeertoolkit
'  Acaddemic Service, schriver Tom Rugg en Phil Feldman
'  uit 1990.  Routine iets aangepast
DECLARE SUB DagNrDatum (DagNmmr&, Jr$, Mnd$, Dg$)

'  dag van de week, zondag is dag 0
'  routine gehaald uit boek QuickBASIC 4.5 Programmeertoolkit
'  Acaddemic Service, schriver Tom Rugg en Phil Feldman
'  uit 1990.  Routine iets aangepast
DECLARE SUB DagWeek (Jr$, Mnd$, Dg$, DagNum, DagNaam$)

'  kleur veranderen
'  routine letterlijk uit een tijdschrift gehaald
'  alleen de verschillende kleuren uitgezocht.
'  0  voor=zwart      achter=zwart
'  1  voor=blauw      achter=blauw
'  2  voor=groen      achter=groen
'  3  voor=cyan       achter=cyan
'  4  voor=rood       achter=rood
'  5  voor=magenta    achter=magenta
'  6  voor=bruin      achter=bruin
'  7  voor=l.grijs    achter=l.grijs
'  8  voor=grijs      achter=grijs
'  9  voor=l.blauw    achter= als 1
' 10  voor=l.groen    achter= als 2
' 11  voor=l.cyan     achter= als 3
' 12  voor=l.rood     achter= als 4
' 13  voor=l.magenta  achter= als 5
' 14  voor=l.geel     achter= als 6
' 15  voor=wit        achter= als 7
DECLARE SUB Kleur (Fore, Back)

'  invoerroutine :  R=regel, K=kolom, Lng=max. lengte invoerveld

'  basis van deze routine uit een tijdschrift gehaald, weet alleen
'  niet meer welk en wie deze routine geschreven heeft, dit was 1990
'  de routine aangepast met extra tekst invoer en Upcase en Up en Down

'  KeyL$ = string waaraan in te typen tekst (Uit$) moet voldoen
'  (als KeyL$ = "" dan moet ExtraKeyL$ een waarde hebben, of andersom)
'  ExtraKeyL$ = string waaraan tekst voor ExtraUit$ moet voldoen, mag nergens
'  overeenkomen met KeyL$
'  (als (Extra)KeyL$ = "" dan is (Extra)Uit$ ook ""
'  ExtraUit$ is maximaal 1 toetsaanslag zonder Enter
'  bv functie-toets  KEY 1, "E" of alleen drukken op de "E"
'  BestW$ = bestaande waarde voor Uit$, als meteen op Enter gedrukt wordt, of
'  de waarde wordt verandert en er wordt daarna op Esc gedrukt dan wordt
'  Uit$ = BestW$.
'  Als ExtraBestW$ een waarde heeft dan wordt deze altijd getoond zonder
'  cursor in inverse video, er kan dan bv via een functie-toets een waarde
'  worden ingevoerd, deze wordt echter niet getoond. Dit kan gebruikt worden
'  als bv aan een getal een bepaalde tekst hangt, buiten de routine moet dan
'  de tekst worden geprint.
'  Als UpCase waar is wordt de invoer omgezet in hoofdletters.
'  Up en Down, als een of beide waar is(zijn) en er wordt op een pijltjes-
'  toets respectievelijk omhoog of omlaag gedrukt dan wordt Uit$ datgene wat
'  op het scherm staat en er wordt uit de routine gesprongen, waarbij Up of
'  Down waar is, in de routine worden ze n.l. onwaar gemaakt, dus als je op
'  een andere manier uit de routine komt zijn ze allebei onwaar.
DECLARE SUB Invoer (R, K, Lng, KeyL$, ExtraKeyL$, BestW$, ExtraBestW$, Uit$, ExtraUit$, UpCase, Up, Down)

'  kader, enkel als Lyn=1, dubbel als 2
'  R1 = bovenste regel, R2 = onderste regel, K1 = kolom links, K2 = kolom rechts
DECLARE SUB Kader (R1, R2, K1, K2, Lyn)

'  naam van de maand aan de hand van een nummer
DECLARE SUB NaamMaand (Md$, MaandN$, Test)

'  wachten op een toets, of als tijd > 0 die bepaalde tijd wachten (seconden)
DECLARE SUB Pause (PauseTijd!)

'  gedeelte scherm schoonmaken
DECLARE SUB RegelsSchoon (Lengte, Regel1, Regel2, VoorKleur, AchterKleur)

'  het hele scherm schoon maken en een boven- en ondertekst neerzetten
'  BovenTitel$ verschijnt gecentreerd op regel 1
'  als Versie$ = "" verschijnt  "HCC-Basic" als ondertekst, op regel 25
'  als Versie$ = Tekst dan verschijnt "HCC-Basic" + Versie$ op regel 25
DECLARE SUB Scherm (BovenTitel$, Versie$)

'  alle functietoetsen schoonmaken
DECLARE SUB SchoonKey ()

'  een text op het scherm zetten op regel R en kolom K, tekst in kleur
'  als K = 0 wordt de tekst in het midden geplaatst
'  Tekst = tekstkleur, Back = achtergrondkleur, A$ = tekst
DECLARE SUB SchRegel (R, K, Tekst, Back, A$)

'  een tekst testen, als tekst niet voldoet dan is Test onwaar
DECLARE SUB TestTekst (IngevoerdeTekst$, KeyList$, Test)

CONST FALSE = 0, TRUE = NOT FALSE

DEFLNG A-Z
SUB DagNrDatum (DagNmmr, Jr$, Mnd$, Dg$)
 TempA = DagNmmr + 68569
 TempB = 4 * TempA \ 146097
 TempA = TempA - (146097 * TempB + 3) \ 4
 Jaar = 4000 * (TempA + 1) \ 1461001
 TempC = Jaar
 TempA = TempA - (1461 * TempC \ 4) + 31
 Maand = 80 * TempA \ 2447
 TempC = Maand
 Dag = TempA - (2447 * TempC \ 80)
 TempA = Maand \ 11
 Maand = Maand + 2 - (12 * TempA)
 Jaar = 100 * (TempB - 49) + Jaar + TempA
 Jr$ = LTRIM$(STR$(Jaar))
 IF LEN(Jr$) = 1 THEN
   Jr$ = "0" + Jr$
 ELSEIF LEN(Jr$) > 2 THEN
   Jr$ = RIGHT$(Jr$, 2)
 END IF
 Mnd$ = LTRIM$(STR$(Maand))
 IF LEN(Mnd$) = 1 THEN Mnd$ = "0" + Mnd$
 Dg$ = LTRIM$(STR$(Dag))
 IF LEN(Dg$) = 1 THEN Dg$ = "0" + Dg$
END SUB

FUNCTION DagNummer& (Jr$, Mnd$, Dg$, Test AS INTEGER)
 Test = FALSE
 ' vanuit datum dagnummer uitrekenen
 IF VAL(Jr$) < 0 THEN EXIT FUNCTION
 IF VAL(Mnd$) < 1 THEN EXIT FUNCTION
 IF VAL(Dg$) < 1 THEN EXIT FUNCTION
 IF VAL(Jr$) > 99 THEN EXIT FUNCTION
 IF VAL(Mnd$) > 12 THEN EXIT FUNCTION
 IF VAL(Dg$) > 31 THEN EXIT FUNCTION
 Y = VAL(Jr$)
 M = VAL(Mnd$)
 D = VAL(Dg$)
 DagNummer& = -1
 IF Y < 0 THEN EXIT FUNCTION
 IF (M < 1) OR (M > 12) THEN EXIT FUNCTION
 IF (D < 1) OR (D > 31) THEN EXIT FUNCTION
 IF Y > 50 AND Y < 100 THEN
   Y = Y + 1900
 ELSEIF Y >= 0 AND Y <= 50 THEN
   Y = Y + 2000
 END IF
 Temp = (M - 14) \ 12
 JulPart = D - 32075 + (1461 * (Y + 4800 + Temp) \ 4)
 JulPart = JulPart + (367 * (M - 2 - Temp * 12) \ 12)
 DagNummer& = JulPart - (3 * ((Y + 4900 + Temp) \ 100) \ 4)
 Test = TRUE
END FUNCTION

DEFINT A-Z
SUB DagWeek (Jr$, Mnd$, Dg$, DagNum, DagNaam$)
 DIM DagText(6) AS STRING
 DagText(0) = "zondag": DagText(1) = "maandag": DagText(2) = "dinsdag"
 DagText(3) = "woensdag": DagText(4) = "donderdag": DagText(5) = "vrijdag"
 DagText(6) = "zaterdag"
 J = VAL(Jr$)
 M = VAL(Mnd$)
 D = VAL(Dg$)
 DagNum = 9
 DagNaam$ = "XX"
 IF J < 0 THEN EXIT SUB
 IF (M < 1) OR (M > 12) THEN EXIT SUB
 IF (D < 1) OR (D > 31) THEN EXIT SUB
 IF J > 50 AND J < 100 THEN
   J = J + 1900
 ELSEIF J >= 0 AND J <= 50 THEN
   J = J + 2000
 END IF
 M = M - 2
 IF (M < 1) OR (M > 10) THEN
   M = M + 12
   J = J - 1
 END IF
 Century = J \ 100
 J = J MOD 100
 Temp = INT(2.6 * M - .19) + D + J + (J \ 4)
 DagNum = (Temp + (Century \ 4) - Century - Century) MOD 7
 IF DagNum < 0 THEN DagNum = DagNum + 7
 DagNaam$ = DagText(DagNum)
END SUB

SUB Invoer (Reg, Kol, Lng, KeyL$, ExtraKeyL$, BestW$, ExtraBestW$, Uit$, ExtraUit$, UpCase, Omhoog, Omlaag)
 Kleur 4, 3
 '------------------------------------------------
 ' Lng = lengte invoerveld, L = lengte text, TextPos = plaats cursor
 '------------------------------------------------
 IF Omhoog = 0 THEN Up = FALSE ELSE Up = TRUE
 IF Omlaag = 0 THEN Down = FALSE ELSE Down = TRUE
 DEF SEG = 0
 IF PEEK(&H463) = &HB4 THEN CsrSize = 13 ELSE CsrSize = 7
 Omhoog = 0: Omlaag = 0
 IF ExtraBestW$ <> "" THEN
   Ebw$ = ExtraBestW$
   ExtraBestW$ = ""
   TijdelijkInvS$ = BestW$
   BestW$ = ""
 END IF
 IF BestW$ <> "" THEN L = LEN(BestW$) ELSE L = 0
 InvS$ = SPACE$(Lng): LSET InvS$ = BestW$
 TextPos = 1
 IF Ebw$ = "" THEN LOCATE Reg, Kol, 0: PRINT InvS$;
 DO
   IF L = Lng THEN Invoegen = FALSE
   IF Ebw$ <> "" THEN
     LOCATE Reg, Kol, 0: PRINT Ebw$; SPACE$(Lng - LEN(Ebw$));
   ELSEIF Invoegen THEN
     LOCATE , , , 0, CsrSize
   ELSE
     LOCATE , , , CsrSize - 2, CsrSize
   END IF
   IF Ebw$ = "" THEN LOCATE Reg, Kol + TextPos - 1, 1
   DO
     Inv$ = INKEY$
   LOOP UNTIL Inv$ <> ""
   IF UpCase THEN Inv$ = UCASE$(Inv$)
   Test = TRUE
   IF INSTR(KeyL$, Inv$) = 0 THEN Test = FALSE
   IF Test THEN
     IF TextPos <= L THEN
       IF Invoegen AND L <= Lng THEN
         MID$(InvS$, TextPos) = Inv$ + MID$(InvS$, TextPos)
         InvS$ = LEFT$(InvS$, Lng)
         L = L + 1
       ELSEIF TextPos <= L THEN
         MID$(InvS$, TextPos, 1) = Inv$
       END IF
       IF TextPos < Lng THEN TextPos = TextPos + 1
     ELSEIF L < Lng THEN
       MID$(InvS$, TextPos) = Inv$
       IF TextPos < Lng THEN TextPos = TextPos + 1
       L = L + 1
     END IF
     LOCATE , Kol, 0: PRINT InvS$;
   ELSEIF NOT Test THEN
     Test = TRUE
     IF INSTR(ExtraKeyL$, Inv$) = 0 THEN Test = FALSE
     IF Test THEN
       ExtraUit$ = Inv$: Einde = TRUE
     ELSE
       SELECT CASE Inv$
         CASE CHR$(8) ' backspace
           IF TextPos > 0 THEN TextPos = TextPos - 1
           IF TextPos > 0 THEN
             MID$(InvS$, TextPos) = MID$(InvS$, TextPos + 1) + " "
             IF L > 0 THEN L = L - 1
           END IF
           IF L = 0 THEN InvS$ = SPACE$(Lng)
           IF TextPos = 0 THEN TextPos = 1
           LOCATE , Kol, 0: PRINT InvS$;
         CASE CHR$(27) ' escape
           Escape = TRUE: Einde = TRUE: ExtraUit$ = Inv$
         CASE CHR$(0) + CHR$(71) ' home
           TextPos = 1
         CASE CHR$(0) + CHR$(72) ' up
           IF Up THEN Omhoog = TRUE: Einde = TRUE
         CASE CHR$(0) + CHR$(75) ' links
           IF TextPos > 1 THEN TextPos = TextPos - 1
         CASE CHR$(0) + CHR$(77) ' rechts
           IF TextPos < Lng THEN TextPos = TextPos + 1
           IF TextPos > L THEN L = TextPos - 1
           IF TextPos > Lng THEN TextPos = Lng
         CASE CHR$(0) + CHR$(79) ' end
           Invoegen = FALSE
           IF L < Lng THEN TextPos = L + 1 ELSE TextPos = Lng
         CASE CHR$(0) + CHR$(80) ' down
           IF Down THEN Omlaag = TRUE: Einde = TRUE
         CASE CHR$(0) + CHR$(82) ' insert
           Invoegen = NOT Invoegen
           IF Invoegen THEN
             LOCATE , , , CsrSize - 1, CsrSize
           ELSE
             LOCATE , , , 1, CsrSize
           END IF
         CASE CHR$(0) + CHR$(83) ' delete
           IF L > 0 AND TextPos <= L THEN
             MID$(InvS$, TextPos) = MID$(InvS$, TextPos + 1) + " "
             LOCATE , Kol, 0: PRINT InvS$;
             L = L - 1
           END IF
         CASE CHR$(13) ' Enter
           Einde = TRUE
           IF InvS$ = SPACE$(Lng) AND TijdelijkInvS$ <> "" THEN
             InvS$ = TijdelijkInvS$ ' dus gelijk aan BestW$
             EXIT DO
           END IF
         CASE ELSE
       END SELECT
     END IF
   ELSEIF Inv$ = CHR$(13) THEN
     Einde = TRUE
   END IF
 LOOP UNTIL Einde
 IF Escape THEN Uit$ = BestW$ ELSE Uit$ = RTRIM$(InvS$)
 LOCATE , , 0, CsrSize - 1, CsrSize
 Kleur 7, 1
END SUB

SUB Kader (R1, R2, K1, K2, Lyn)
 IF Lyn = 1 OR Lyn = 3 THEN
   IF Lyn = 1 THEN
   LOCATE R1, K1: PRINT "" + STRING$(K2 - K1 - 1, 196) + "";
   ELSE
   LOCATE R1, K1: PRINT "" + STRING$(K2 - K1 - 1, 196) + "";
   END IF
   FOR x = R1 + 1 TO R2 - 1
     LOCATE x, K1: PRINT ""; : LOCATE x, K2: PRINT "";
   NEXT x
   LOCATE R2, K1: PRINT "" + STRING$(K2 - K1 - 1, 196) + "";
 ELSEIF Lyn = 2 OR Lyn = 4 THEN
   IF Lyn = 2 THEN
   LOCATE R1, K1: PRINT "" + STRING$(K2 - K1 - 1, 205) + "";
   ELSE
   LOCATE R1, K1: PRINT "" + STRING$(K2 - K1 - 1, 205) + "";
   END IF
   FOR x = R1 + 1 TO R2 - 1
     LOCATE x, K1: PRINT ""; : LOCATE x, K2: PRINT "";
   NEXT x
   LOCATE R2, K1: PRINT "" + STRING$(K2 - K1 - 1, 205) + "";
 END IF
END SUB

SUB Kleur (Fore, Back)
' Doel     : zet de voor- en achtergrond kleur
' Input    : Fore  0-16, Back 0-16
' Output   : niets
' aanroep van Kleur i.p.v. COLOR bezuinigt nogal op assemblercode:
' 13 i.p.v. 22 bytes. Zie het boek "BASIC, techniques and utilities"
' door Ethan Winer, blz. 353
'
' De aanroep van Kleur verschilt in zoverre van COLOR dat om het
' blinkbit aan te zetten niet Fore met 16 maar Back met 8 moet worden
' opgehoogd. De waardenrange van Back is dus dezelfde als die van Fore
'
' Dus:
' Waarde van Fore : 0-16
' Waarde van Back : 0-16
DIM F
DIM B
IF Back AND 8 THEN
  F = Fore OR 16
  B = Back XOR 8
ELSE
  F = Fore
  B = Back
END IF
COLOR F, B
END SUB

SUB NaamMaand (Md$, MaandN$, Test)
 Test = TRUE
 M = VAL(Md$)
 IF M < 1 OR M > 12 THEN Test = FALSE: EXIT SUB
 DIM Maand$(12)
 Maand$(1) = "januari": Maand$(2) = "februari": Maand$(3) = "maart"
 Maand$(4) = "april": Maand$(5) = "mei": Maand$(6) = "juni"
 Maand$(7) = "juli": Maand$(8) = "augustus": Maand$(9) = "september"
 Maand$(10) = "oktober": Maand$(11) = "november": Maand$(12) = "december"
 MaandN$ = Maand$(M)
END SUB

DEFSNG B-Z
' pause in seconden
' als pause 0, wachten op toetsaanslag en melding geven
SUB Pause (PauseTijd!)
 IF PauseTijd! > .01 THEN
   Begin! = TIMER
   LOCATE , , 0
   DO
     Nu! = TIMER
     IF Nu! < Begin! THEN Nu! = Nu! + 86400
   LOOP UNTIL (Nu! - Begin!) >= PauseTijd!
   EXIT SUB
 ELSE
   ' zet een tekst linksonder neer
   SchRegel 25, 5, 0, 7, " druk op de spatiebalk "
   DO: LOOP WHILE INKEY$ = ""
   ' en haalt deze weer weg
   SchRegel 25, 5, 7, 1, SPACE$(23)
 END IF
END SUB

DEFINT B-Z
SUB RegelsSchoon (L, Y1, Y2, V, A)
 IF L = 80 THEN
   x = 1
 ELSEIF L = 78 THEN
   x = 2
 ELSEIF L = 76 THEN
   x = 3
 END IF
 FOR Y = Y1 TO Y2
   SchRegel Y, x, V, A, SPACE$(L)
 NEXT Y
END SUB

SUB Scherm (BovenTitel$, Versie$)
 Kleur 15, 1: CLS
 SchRegel 1, 0, 14, 4, "  " + BovenTitel$ + "  "
 IF Versie$ <> "" THEN
   SchRegel 25, 0, 14, 1, " HCC-Basic " + Versie$
 ELSE
   SchRegel 25, 0, 14, 1, " HCC-Basic "
 END IF
END SUB

DEFSNG A-Z
SUB SchoonKey
 KEY 1, "": KEY 2, "": KEY 3, "": KEY 4, "": KEY 5, ""
 KEY 6, "": KEY 7, "": KEY 8, "": KEY 9, "": KEY 10, ""
 KEY(1) OFF: KEY(2) OFF: KEY(3) OFF: KEY(4) OFF: KEY(5) OFF
 KEY(6) OFF: KEY(7) OFF: KEY(8) OFF: KEY(9) OFF: KEY(10) OFF
 KEY(11) OFF: KEY(12) OFF: KEY(13) OFF: KEY(14) OFF
END SUB

DEFINT A-Z
SUB SchRegel (Reg, Kol, Tekst, Back, A$)
 IF Kol = 0 THEN Kol = (40 - LEN(A$) \ 2) + 1
 IF Kol = 0 THEN Kol = 1
 Kleur Tekst, Back
 LOCATE Reg, Kol
 PRINT A$;
END SUB

SUB TestTekst (Ingevoerde$, KeyList$, Test)
 ' Ingevoerde$ = de te testen string   KeyList$ = de string waarop getest wordt
 Test = TRUE
 FOR J = 1 TO LEN(Ingevoerde$)
   IF INSTR(KeyList$, MID$(Ingevoerde$, J, 1)) = 0 THEN
     Test = FALSE: EXIT FOR
   END IF
 NEXT J
END SUB

